perm filename SMALL.FAI[XX,LCS]2 blob
sn#182709 filedate 1975-10-21 generic text, type T, neo UTF8
00100 TITLE SMALL
00200 INTERNAL RJBX,CENTX,EXTEN,JDRAW,CENTER,LINX,UNPACK,ROFF,NOIR
00300 INTERNAL NOZERO,EXCH,BMS,IABS,RHORZ,ABS,RTLINE,FLOAT,IFIX
00400 EXTERNAL .COMM.,STF,POSI,LL,LINES,BM,XRN,PTR,AMOD,MOD
00450 EXTERNAL PLTR,SQRT
00500 ;; DEFINE FLOAT(N)
00600 ;; < TLC N,232000
00700 ;; FADR N,N >
00800 DEFINE FIXX(N)
00900 < JUMPGE N,.+5
01000 MOVNS N
01100 FIX N,233000
01200 MOVNS N
01300 CAIA
01400 FIX N,233000 > ; TO FIX IT LIKE 'IFIX' DOES.
01500
01600
01700
01800 RJBX: 0 ;R3=R3+R*RSTJ2
01900 MOVE 2,@(16)
02000 FMPR 2,STF+=8
02100 FADRM 2,.COMM.+=4
02200 JRA 16,1(16)
02300
02400 CENTX: 0 ;CENTX=POS-18.*RSTJ2+AMOD(R4,100.0)*RSTJ2*7.
02500 JSA 16,AMOD
02600 JUMP .COMM.+5
02700 JUMP [=100.0]
02800 FMPR [=7.0]
02900 FSBR [=18.0]
03000 FMPR STF+=8
03100 FADR POSI+=9
03200 MOVEM .COMM.+2
03300 JRA 16,(16)
03600
03700
03800 EXTEN: 0 ;FUNCTION EXTEN(X)
03900 HRRM 16,.+2
04000 JSA 16,AMOD ;EXTEN=AMOD(X,1.)*10.
04100 JUMP @0
04200 JUMP [=1.0]
04300 FMPR [=10.0]
04400 JRA 16,1(16)
04500
04600
04700 AA: 0
04800 BB: 0
04900 CC: 0
05000 DD: 0
05100
05200 JDRAW: 0 ;SUBROUTINE JDRAW(M,R3,CENTR,RSTJ2,RX,RY)
05300 MOVE 2,@3(16) ;COMMON/LL/LL
05400 MOVE 13,@4(16) ;DIMENSION M(1)
05500 FMPR 13,2 ;RC=RX*RSTJ2
05600 MOVE 14,@5(16) ;RD=RY*RSTJ2
05700 FMPR 14,2 ;13 HAS RC, 14 HAS RD
05800 MOVE 3,@(16) ;DO 2 K=2,M(1)
05900 HRRZ 12,(16) ; BRING IN ADR. OF M (ZERO LEFT HALF)
06000 MOVE 10,(12) ;PUT ADR. OF M IN 10
06100 ADDI 10,-1(12)
06200 L2: AOJ 12, ; SET UP LOOP
06300 CAILE 12,(10) ; SEE IF WE'VE PASSED END OF LOOP
06400 JRA 16,6(16) ; GO HOME
06500 HRRZM 12,.+4 ; PUT ADR. OF VALUE M(K) IN LAST JUMP
06600 ; CALL UNPACK(A,B,M(K))
06700 JSA 16,UNPACK
06800 JUMP AA
06900 JUMP BB
07000 JUMP
07100 ;2 CALL LINES(FLOAT(A)*RC+R3,FLOAT(B)*RD+CENTR,LL)
07200 ;; JSA 16,FLOAT
07300 ;; JUMP AA
07400 MOVE 0,AA
07500 TLC 0,232000
07600 FADR 0,0
07700 FMPR 13
07800 FADR @1(16)
07900 MOVEM AA
08000 ;; JSA 16,FLOAT
08100 ;; JUMP BB
08200 MOVE 0,BB
08300 TLC 0,232000
08400 FADR 0,0
08500 FMPR 14
08600 FADR @2(16)
08700 MOVEM BB
08800 JSA 16,LINES
08900 JUMP AA
09000 JUMP BB
09100 JUMP LL
09200 JRST L2
09300
09400 CENTER: 0 ; SUBROUTINE CENTER(CNTR)
09500 ; TO CENTER ITEMS CREATED WITH DRAWING PROG.
09600 ; COMMON /STF/RSTFAC(8),RSTJ2
09700 ; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
09800 ; COMMON/POSI/STF(8),JJ2,POS
09900 ; EQUIVALENCE (R4,RJQ(2))
10000 JSA 16,AMOD ;CNTR=POS+(2+AMOD(R4,100.)*7)*RSTJ2
10100 JUMP .COMM.+5
10200 JUMP [=100.0]
10300 FMPR [=7.0]
10400 FADR [=2.0]
10500 FMPR STF+=8
10600 FADR POSI+=9
10700 MOVEM @(16)
10800 JRA 16,1(16)
10900
11000 LINX: 0 ; SUBROUTINE LINX(A,B,C,D)
11100 ; C SAVES SPACE FOR SINGLE LINES.
11200 MOVE @(16) ;CALL LINES(A,B,3)
11300 MOVEM AA
11400 MOVE @1(16)
11500 MOVEM BB
11600 MOVE @2(16) ;CALL LINES(C,D,2)
11700 MOVEM CC
11800 MOVE @3(16)
11900 MOVEM DD
12000 JSA 16,LINES
12100 JUMP AA
12200 JUMP BB
12300 JUMP [=3]
12400 JSA 16,LINES
12500 JUMP CC
12600 JUMP DD
12700 JUMP [=2]
12800 JRA 16,4(16)
12900
13000 UNPACK: 0 ; SUBROUTINE UNPACK(M,N,I)
13100 ; COMMON/LL/L
13200 ;C L IS FOR VIS. OR INVIS. LINES.
13300 MOVE @2(16) ; N=I
13400 MOVE 3,
13500 IDIV [=100000000] ; M=N/100000000
13600 JUMPE O2 ; IF(M.EQ.0)GO TO 2
13700 MOVEI 2,3 ; L=3
13800 IMUL [=100000000] ; N=N-100000000*M
13900 MOVNS
14000 ADD 3,0 ; 3 HAS N, 4 HAS M(LATER)
14100 JRST M2
14200 O2: MOVEI 2,2 ; L=2
14300 M2: MOVE 4,3
14400 IDIVI 4,23420 ;2 M=N/10000
14500 MOVEM 2,LL ; PUTS AWAY L
14600 MOVEM 3,AA
14700 JSA 16,MOD ; N=MOD(N,10000)
14800 JUMP AA
14900 JUMP [=10000]
15000 MOVEI 2,1750 ; IF(M.GT.1000)M=1000-M
15100 CAML 2,4
15200 JRST N2
15300 MOVEI 2,1750
15400 MOVNS 4
15500 ADD 4,2
15600 N2: CAML 2, ; IF(N.GT.1000)N=1000-N
15700 JRST P2
15800 MOVNS
15900 ADD 2
16000 P2: MOVEM 4,@(16)
16100 MOVEM 0,@1(16)
16200 JRA 16,3(16)
16300
16400 ROFF: 0 ; FUNCTION ROFF(R)
16500 MOVSI 200400 ; S=.5
16600 SKIPGE 1,@(16) ; IF(R)S=-S
16700 MOVNS
16800 FADR 1 ; ROFF=R+S
16900 JRA 16,1(16)
17000
17100 NOZERO: 0 ;SUBROUTINE NOZERO(X)
17200 SKIPE @(16) ; IF(X.EQ.0)X=1
17300 JRA 16,1(16)
17400 MOVE [=1.0] ; MAKE ALL ZEROS INTO ONES.
17500 MOVEM @(16)
17600 JRA 16,1(16)
17700
17800 EXCH: 0 ; SUBROUTINE EXCH(X,Y)
17900 MOVE @(16)
18000 EXCH 0,@1(16)
18100 MOVEM 0,@(16)
18300 JRA 16,2(16)
18400
18500 BMS: 0 ; SUBROUTINE BMS
18600 MOVE BM+1 ;COMMON/STF/RSTFAC(-3/4),RSTJ2/BM/RA,RC,RKY
18700 FMPR STF+=8 ; CALL LINES(RA,RJY+RC*RSTJ2,2)
18800 FADR BM+2
18900 MOVEM BB
19000 JSA 16,LINES ; END
19100 JUMP BM
19200 JUMP BB
19300 JUMP [2]
19400 JRA 16,(16)
19500
19600 IABS: 0 ; FUNCTION IABS(N)
19700 MOVM 0,@(16) ;BECAUSE IABS IN LIB40 HAS A BUG.
19800 JRA 16,1(16) ; IABS=N ; IF(N)IABS=-N
19900
20000 RHORZ: 0 ; FUNCTION RHORZ(R)
20100 MOVE @(16) ; RHORZ=R*5.96-596.
20200 FMPR [=5.96]
20300 FSBR [=596.0]
20400 JRA 16,1(16)
20500
20600 ABS: 0
20700 JRST IABS+1
20800
20900 RTLINE: 0 ;FUNCTION RTLINE(L)
21000 MOVE 2,.COMM. ;COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)/XRN/RN(4000)
21100 CAMLE 2,[=4.0] ;RTLINE=-1
21200 JRST ZRO ;IF(R2.GT.4)GO TO 1
21300 HRRZ @(16) ;IF(RN(L+2).NE.R2)RETURN
21400 HRRZI 3,XRN ; PUT ADR. OF XRN IN 3
21500 ADD 3, ; 1 RTLINE=0
21600 SETO
21700 CAMN 2,1(3)
21800 ZRO: SETZ
21900 JRA 16,1(16)
22000
22100 FLOAT: 0
22200 MOVE 0,@(16)
22300 TLC 0,232000
22400 FADR 0,0
22500 JRA 16,1(16)
22600 IFIX: 0
22700 MOVE 0,@(16)
22800 JUMPGE 0,.+5
22900 MOVNS 0
23000 FIX 0,233000
23100 MOVNS 0
23200 CAIA
23300 FIX 0,233000
23400 JRA 16,1(16)
23500
23600 ;;;MOD: 0
23700 ;;; MOVE 2,@(16)
23800 ;;; IDIV 2,@1(16)
23900 ;;; IMUL 2,@1(16)
24000 ;;; MOVE @(16)
24100 ;;; SUB 2
24200 ;;; JRA 16,2(16)
24300
25000 NOIR: 0
25100 JRA 16,1(16) ; DUMMY ******
35200 END